home *** CD-ROM | disk | FTP | other *** search
/ SPACE 2 / SPACE - Library 2 - Volume 1.iso / apps / 255 / applic / tny_boot.pas < prev    next >
Pascal/Delphi Source File  |  1988-06-14  |  11KB  |  467 lines
  1. PROGRAM tny_boot ;
  2.  
  3.   TYPE
  4.     str255 = string[ 255 ];
  5.     fn_range = 1..14 ;
  6.     fname = PACKED ARRAY [ fn_range ] OF char ;
  7.     frec = PACKED RECORD
  8.              reserved : PACKED ARRAY [ 0..19 ] OF byte ;
  9.              resvd2 : byte ;
  10.              attrib : byte ;
  11.              time_stamp : integer ;
  12.              date_stamp : integer ;
  13.              size : long_integer ;
  14.              name : fname ;
  15.            END ;
  16.     path_name = PACKED ARRAY [ 1..80 ] OF char ;
  17.     file_array = array[ 1..250 ] of str255;
  18.     InbufType = packed array[1..32044] of byte;
  19.     Pallete = packed array[0..15] of integer;
  20.     Screen = packed array[1..32000] of byte;
  21.     Ptr_screen = ^screen;                     { pointer to the screen array }
  22.  
  23.  
  24.     var rec_num,i,the_rez : integer;
  25.     pics : file_array;
  26.         tiny_path_str : str255;
  27.         tny_path : path_name;
  28.         inbuf : InbufType;
  29.         Pal : Pallete;
  30.         TinyPic : Screen;
  31.     l : long_integer;
  32.     show_title : boolean;
  33.  
  34. CONST
  35.     Read_Only = 0;
  36.     null_char = #0;
  37.  
  38. {SCREEN ROUTINES}
  39.  
  40. PROCEDURE GotoXY( x, y : Short_Integer );
  41.     EXTERNAL;
  42.  
  43. FUNCTION Physbase : Ptr_screen;
  44.    XBIOS( 2 );
  45.  
  46. FUNCTION Get_rez : Integer;
  47.    XBIOS( 4 );
  48.  
  49. PROCEDURE Set_screen(Logical_Screen,Physical_Screen:Long_integer; Rez:integer);
  50.    XBIOS( 5 );
  51.  
  52. PROCEDURE Setpallete(VAR Pal:Pallete );
  53.    XBIOS( 6 );
  54.  
  55. FUNCTION Setcolor(ColorNumber,Tint:integer):integer;
  56.    XBIOS( 7 );
  57.  
  58. PROCEDURE vsync;
  59.    XBIOS( 37 );
  60.  
  61.  
  62. {------------ FILE ROUTINES ---------------}
  63.  
  64. FUNCTION f_open(VAR name :Path_Name; mode :Integer ) :Integer;
  65.     GemDos($3d);
  66.  
  67. FUNCTION f_close(handle :Integer) :Integer;
  68.     GemDos($3e);
  69.  
  70. FUNCTION f_read(handle :Integer; count :Long_Integer;
  71.                 VAR buffer :InBufType) :Long_Integer;
  72.     GemDos($3f);
  73.  
  74.  
  75. function inkey : char;
  76.  
  77.     var char_val : integer;
  78.         val_return : long_integer;
  79.         key : char;
  80.  
  81.     function bconstat( device : integer ) : boolean;
  82.         bios( 1 );
  83.  
  84.     function bconin( device : integer ) : long_integer;
  85.         bios( 2 );
  86.  
  87. begin
  88.     if bconstat( 2 ) then  { keypressed }
  89.         val_return := bconin( 2 )
  90.       else
  91.         val_return := 0;
  92.  
  93.      char_val := int( val_return );
  94.          key := chr( char_val );
  95.      inkey := key;
  96.  
  97. end;  { inkey }
  98.  
  99.  
  100. procedure make_path( path_string : str255; var ipath : path_name );
  101.  
  102. var i : integer;
  103. begin
  104.     FOR i := 1 TO length( path_string ) DO
  105.       ipath[i] := path_string[i] ;
  106.     ipath[ length(path_string)+1 ] := chr(0) ;
  107.  
  108. end;  { make_path }
  109.  
  110.  
  111. function good_pic( pic : str255 ) : boolean;
  112.  
  113.     var pic_name : path_name;
  114.         name : str255;
  115.         res, f : integer;
  116. begin
  117.     name := copy( tiny_path_str, 1, length( tiny_path_str) - 5 );
  118.     name := concat( name, pic );
  119.     make_path( name, pic_name );
  120.     F := f_open(Pic_Name,Read_Only);
  121.     L := f_read(f, 32044, inbuf);
  122.     f := f_close(f);
  123.     res := inbuf[ 1 ];
  124.     if res > 2 then
  125.     res := res - 3;
  126.  
  127.     if  ( ( the_rez = 2 ) and ( res < 2 ) ) or 
  128.         ( (the_rez < 2 ) and ( res = 2 ) )  then
  129.     good_pic := false
  130.     else
  131.     good_pic := true;
  132.  
  133. end;  { good_pic }
  134.  
  135.  
  136. {$P-} { turn pointer checking off.. }
  137.  
  138. Procedure Show_Tiny_Screen( picname : str255 );
  139.  
  140. CONST
  141.     Read_Only = 0;
  142.  
  143. VAR
  144.     i,j,
  145.     res,                    {Screen Resolution}
  146.     DelayTime,              {Number of seconds to display pic on screen}
  147.     RotStart,               {Start color number to rotate}
  148.     RotEnd,                 {End color number to rotate}
  149.     RotSpeed,               {Speed and direction to rotate}
  150.     RotRevolutions,         {Number of revolutions to make}
  151.     RotationsMade,          
  152.     TimeToKill,
  153.     f :Integer;
  154.     S_ptr : Ptr_screen;         { a pointer to a packed array of bytes... }
  155.     RotInfo:Boolean;            {Is there rotation info for the pic?}
  156.  
  157. {-----------------------------------------------------------------------}
  158.  
  159. PROCEDURE DecodePic;
  160. VAR
  161.     i, j :INTEGER;
  162.     curplane, curln, curcol :Integer;
  163.     ctrlptr, dataptr :Integer;
  164.     ctrlcnt, datacnt :Integer;
  165.  
  166. {..........................................}
  167. PROCEDURE PutWord;
  168.  
  169. VAR pos :Integer;
  170.  
  171. BEGIN {PUT WORD}
  172.    pos := ShL(curplane,1) + curln * 160 + ShL(curcol,3);
  173.    TinyPic[pos+1] := inbuf[dataptr];
  174.    TinyPic[pos+2] := inbuf[dataptr+1];
  175.    curln := curln+1;
  176.    IF curln >= 200 then
  177.    Begin
  178.       curln := 0;
  179.       curcol := curcol + 1;
  180.       If curcol >= 20 then
  181.       Begin
  182.          curcol := 0;
  183.          curplane := curplane + 1;
  184.       End
  185.    End
  186. End; {PUT WORD}
  187. {..........................................}
  188.  
  189. BEGIN {DECODE PIC}
  190.  
  191.     res := inbuf[1];
  192.     rotInfo := True;
  193.     IF res > 2 THEN res := res-3 ELSE rotInfo := False;
  194.  
  195.     ctrlptr := 2;
  196.     IF rotInfo THEN
  197.     Begin
  198.        ctrlptr := ctrlptr + 4;
  199.        RotEnd := (inbuf[2] & 15);
  200.        RotStart := ShR(inbuf[2],4);
  201.        RotSpeed := inbuf[3];
  202.        RotRevolutions := (inbuf[4] * 256) + inbuf[5];
  203.     End;
  204.  
  205.     FOR i:=1 TO 16 DO
  206.       Pal[i-1] := (inbuf[((i-1)*2)+ctrlptr]*256) + inbuf[((i-1)*2)+ctrlptr+1];
  207.     ctrlptr:=ctrlptr+32;
  208.  
  209.     ctrlcnt:=ShL(inbuf[ctrlptr],8)+inbuf[ctrlptr+1];
  210.     datacnt:=ShL(inbuf[ctrlptr+2],8)+inbuf[ctrlptr+3];
  211.     ctrlptr:=ctrlptr+4;
  212.     dataptr:=ctrlptr+ctrlcnt;
  213.     curplane:=0; curln:=0; curcol:=0;
  214.  
  215.     REPEAT
  216.         IF inbuf[ctrlptr]>=128 THEN BEGIN
  217.             FOR j:=1 TO (256-inbuf[ctrlptr]) DO BEGIN
  218.                 PutWord;
  219.                 dataptr:=dataptr+2;
  220.                 END;
  221.             ctrlptr:=ctrlptr+1;
  222.             END
  223.    else IF inbuf[ctrlptr]=0 THEN BEGIN
  224.             FOR j:=1 TO (inbuf[ctrlptr+1]*256+inbuf[ctrlptr+2]) DO
  225.                 PutWord;
  226.             ctrlptr:=ctrlptr+3;
  227.             dataptr:=dataptr+2;
  228.             END
  229.    else IF inbuf[ctrlptr]=1 THEN BEGIN
  230.             FOR j:=1 TO (inbuf[ctrlptr+1]*256+inbuf[ctrlptr+2]) DO BEGIN
  231.                 PutWord;
  232.                 dataptr:=dataptr+2;
  233.                 END;
  234.             ctrlptr:=ctrlptr+3;
  235.             END
  236.    else BEGIN
  237.             FOR j:=1 TO inbuf[ctrlptr] DO    {inbuf[ctrlptr]>1}
  238.                 PutWord;
  239.             ctrlptr:=ctrlptr+1;
  240.             dataptr:=dataptr+2;
  241.             END;
  242.         UNTIL (curplane>=4);
  243.  
  244. END; {DECODE_PIC}
  245.  
  246. procedure title;
  247.  
  248.     var i, x1,x2, long, y : integer;
  249. begin
  250.     if show_title then
  251.      begin
  252.         if res = 0 then
  253.           begin
  254.         x1 := 1;
  255.         x2 := 40;
  256.       end
  257.     else
  258.       begin
  259.         x1 := 2;
  260.         x2 := 79;
  261.       end;;
  262.     long := length( picname ) - 4;
  263.     y := ( 25 - long ) div 2;
  264.     
  265.     for i := 1 to long do
  266.        begin
  267.         gotoxy( i + y - 1, x1 );
  268.         write( picname[ i ] );
  269.        end;
  270.     picname := 'Tiny Boot by dwb';
  271.     long := 16;
  272.     y := 5;
  273.     for i := 1 to long do
  274.        begin
  275.         gotoxy( i + y -1, x2 );
  276.         write( picname[ i ] );
  277.        end;
  278.    end;
  279.  
  280. end; { title }    
  281.  
  282. {---------------------------------------------------------------------}
  283.  
  284. Begin {SHOW_WELCOME}
  285.  
  286.         DecodePic;
  287.         for i := 0 to 15 do f := Setcolor(i,Pal[i]); {Set Pallete colors}
  288.         Set_Screen(-1,-1,res);    { set correct resolution }
  289.         S_ptr := Physbase;        { grab location of screen... }
  290.         S_ptr^ := TinyPic;        { stuff picture into screen }
  291.     title;
  292.  
  293. End; {Show_Welcome}
  294.  
  295. {$P=}  {Turn pointer checking back on}
  296.  
  297. { ------------------------------------------------------ }
  298.  
  299. Function Random( Low, Hi : Integer ) : Integer;
  300.  
  301.     Function XB_Rnd : Long_Integer; 
  302.        Xbios( 17 );
  303.  
  304.     Function Rnd : Real;
  305.  
  306.        Begin
  307.           Rnd := XB_Rnd / 16777216.0;
  308.        End;
  309.  
  310. Begin
  311.       Random := Low + Trunc( Rnd * ( Hi - Low +1 ) );
  312.  
  313. End;   { RANDOM.PAS }
  314.  
  315.  
  316. FUNCTION IO_Result : Short_Integer ;
  317.     EXTERNAL ;
  318.  
  319.  
  320. PROCEDURE IO_Check( YesNo : Boolean ) ;
  321.     EXTERNAL ;
  322.  
  323.  
  324.  
  325. FUNCTION get_current_drive : integer ;
  326.     GEMDOS( 25 );
  327.  
  328.  
  329. procedure directory( path : path_name ; 
  330.              var fs : file_array; var total : integer);
  331.  
  332.   VAR
  333.     r : frec ;
  334.     i : fn_range ;
  335.     kar : char;
  336.  
  337.     PROCEDURE set_dta( VAR buf : frec ) ;
  338.         GEMDOS( $1a ) ;
  339.  
  340.     FUNCTION get_first( VAR path : path_name ; 
  341.                 search_attrib :integer ):integer ;
  342.         GEMDOS( $4e ) ;
  343.  
  344.      FUNCTION get_next : integer ;
  345.         GEMDOS( $4f ) ;
  346.  
  347.     PROCEDURE store_file( VAR r : frec ) ;
  348.  
  349.           var     i : fn_range ;
  350.               temp : str255;
  351.  
  352.         BEGIN
  353.               temp := '';
  354.               WITH r DO
  355.             BEGIN
  356.                   i := 1 ;
  357.                   WHILE (i <= 14) AND (name[i] <> chr(0)) DO
  358.                     BEGIN
  359.                           temp := concat( temp, name[ i ] );
  360.                         i := i + 1
  361.                 END ;
  362.                  total := total + 1;
  363.                     fs[ total ] := temp
  364.              END ;
  365.  
  366.         END ;  { store_file }
  367.  
  368. BEGIN
  369.     set_dta( r ) ;
  370.     IF get_first( path, 0 ) >= 0 THEN
  371.       REPEAT
  372.         store_file( r ) ;
  373.     kar := inkey;
  374.     if kar <> null_char then
  375.          if ( kar = 'Q' ) or ( kar = 'q' ) then
  376.             halt;
  377.       UNTIL get_next < 0 ;
  378.  
  379. end; { directory }
  380.  
  381.  
  382. function exist( name : str255 ) : boolean;
  383.  
  384.     var error : integer;
  385.         which : file of text;
  386. begin
  387.         io_check( false );
  388.     reset( which, name );
  389.         error := io_result;
  390.     if error = 0 then
  391.         exist := true
  392.     else
  393.         exist := false;
  394.     close( which );
  395.     io_check( true );
  396.  
  397. end;  { exist }
  398.  
  399.  
  400. procedure check_alt_path( var tiny_pth : str255 );
  401.  
  402.     var which : file of text;
  403.             title_show, file_name : str255;
  404. begin
  405.     
  406.     file_name := concat( tiny_pth, 'TNY_BOOT.INF' );
  407.     if exist( file_name ) then
  408.       begin
  409.         reset( which, file_name );
  410.         readln( which, tiny_pth );
  411.         readln( which, title_show );
  412.         if tiny_pth[ length( tiny_pth) ] <> '\' then
  413.             tiny_pth := concat( tiny_pth, '\' );
  414.  
  415.         if ( title_show[ 1 ] = 'n' ) or
  416.            ( title_show[ 1 ] = 'N' ) then
  417.             show_title := false;
  418.            end;
  419.  
  420. end;  { check_alt_path }
  421.  
  422.  
  423. procedure get_pic_names;
  424.  
  425.     var drnum : integer;
  426.         drive : char;
  427. BEGIN
  428.     rec_num := 0;
  429.     drnum := get_current_drive;
  430.         drive := chr( drnum + 65 );
  431.     tiny_path_str := concat( drive, ':\AUTO\');
  432.     check_alt_path( tiny_path_str );
  433.     tiny_path_str := concat( tiny_path_str, '*.TNY' );
  434.     make_path( tiny_path_str, tny_path );
  435.     directory( tny_path, pics, rec_num );
  436.  
  437. END;  { get_pic_names }
  438.  
  439.  
  440. procedure select_pic( pic : file_array; total : integer;
  441.       VAR select : integer ) ;
  442.  
  443.     var rot : integer;
  444.         ok : boolean;
  445. begin
  446.    rot := 0;
  447.    repeat
  448.     select := random( 1, total );
  449.        ok := good_pic( pic[ select ] );
  450.         rot := rot + 1;
  451.    until ( ok ) or ( rot > 50 );
  452.    if not ok then
  453.     select := 0;
  454.  
  455. end; { select_pic }
  456.     
  457.  
  458. begin  { ------------- main routine ----------- }
  459.  
  460.     show_title := true;
  461.         the_rez := get_rez;
  462.     get_pic_names;
  463.     select_pic( pics, rec_num, i);
  464.     if i > 0 then
  465.         show_tiny_screen( pics[ i ] );
  466. end.
  467.